Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume12 / ffccc / part02 < prev next >

Wrap

Text File | 1990-05-14 | 47.2 KB | 1,197 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i088: Floppy - Fortran Coding Convention Checker Part 02/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 88 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part02 #!/bin/sh echo 'Start of Floppy, part 02 of 11:' echo 'x - DEFSTA.f' sed 's/^X//' > DEFSTA.f << '/' X SUBROUTINE DEFSTA(INDE,ILEN,CNAM,FOK) XC For statement class INDE returns length of FORTRAN XC keyword (ILEN), keyword name (CNAM*25) and logical XC FOK, which is set if the statement is to be checked XC for embedded blanks. XC INPUT ; INDE XC OUTPUT; ILEN XC CNAM XC FOK XC X include 'PARAM.h' X include 'USUNIT.h' X CHARACTER*25 CNAM X LOGICAL FOK X PARAMETER (LFOK=37) X DIMENSION IFOK(LFOK) X CHARACTER CFORTS(MXSTAT)*25 X DATA CFORTS( 1)/'ASSIGN '/ X DATA CFORTS( 2)/'BACKSPACE '/ X DATA CFORTS( 3)/'BLOCKDATA '/ X DATA CFORTS( 4)/'BUFFERIN '/ X DATA CFORTS( 5)/'BUFFEROUT '/ X DATA CFORTS( 6)/'CONTINUE '/ X DATA CFORTS( 7)/'CALL '/ X DATA CFORTS( 8)/'COMMON '/ X DATA CFORTS( 9)/'COMPLEXFUNCTION '/ X DATA CFORTS( 10)/'COMPLEX '/ X DATA CFORTS( 11)/'COMPLEX '/ X DATA CFORTS( 12)/'CHARACTERFUNCTION '/ X DATA CFORTS( 13)/'CHARACTER '/ X DATA CFORTS( 14)/'CHARACTER '/ X DATA CFORTS( 15)/'CLOSE '/ X DATA CFORTS( 16)/'DATA '/ X DATA CFORTS( 17)/'DIMENSION '/ X DATA CFORTS( 18)/'DO '/ X DATA CFORTS( 19)/'DO '/ X DATA CFORTS( 20)/'DECODE '/ X DATA CFORTS( 21)/'DOUBLEPRECISIONFUNCTION '/ X DATA CFORTS( 22)/'DOUBLEPRECISION '/ X DATA CFORTS( 23)/'END '/ X DATA CFORTS( 24)/'ENDIF '/ X DATA CFORTS( 25)/'ENDFILE '/ X DATA CFORTS( 26)/'ENTRY '/ X DATA CFORTS( 27)/'EQUIVALENCE '/ X DATA CFORTS( 28)/'EXTERNAL '/ X DATA CFORTS( 29)/'ELSE '/ X DATA CFORTS( 30)/'ELSEIF '/ X DATA CFORTS( 31)/'ENCODE '/ X DATA CFORTS( 32)/'FORMAT '/ X DATA CFORTS( 33)/'FUNCTION '/ X DATA CFORTS( 34)/'GOTO '/ X DATA CFORTS( 35)/'GOTO '/ X DATA CFORTS( 36)/'GOTO '/ X DATA CFORTS( 37)/'IF '/ X DATA CFORTS( 38)/'IF '/ X DATA CFORTS( 39)/'IF '/ X DATA CFORTS( 40)/'ILLEGAL '/ X DATA CFORTS( 41)/'INTEGERFUNCTION '/ X DATA CFORTS( 42)/'INTEGER '/ X DATA CFORTS( 43)/'INTEGER '/ X DATA CFORTS( 44)/'IMPLICIT '/ X DATA CFORTS( 45)/'INQUIRE '/ X DATA CFORTS( 46)/'INTRINSIC '/ X DATA CFORTS( 47)/'LOGICALFUNCTION '/ X DATA CFORTS( 48)/'LOGICAL '/ X DATA CFORTS( 49)/'LOGICAL '/ X DATA CFORTS( 50)/'LEVEL '/ X DATA CFORTS( 51)/'NAMELIST '/ X DATA CFORTS( 52)/'OPEN '/ X DATA CFORTS( 53)/'PRINT '/ X DATA CFORTS( 54)/'PARAMETER '/ X DATA CFORTS( 55)/'PAUSE '/ X DATA CFORTS( 56)/'PROGRAM '/ X DATA CFORTS( 57)/'PUNCH '/ X DATA CFORTS( 58)/'READ '/ X DATA CFORTS( 59)/'READ '/ X DATA CFORTS( 60)/'REALFUNCTION '/ X DATA CFORTS( 61)/'REAL '/ X DATA CFORTS( 62)/'REAL '/ X DATA CFORTS( 63)/'RETURN '/ X DATA CFORTS( 64)/'REWIND '/ X DATA CFORTS( 65)/'SAVE '/ X DATA CFORTS( 66)/'STOP '/ X DATA CFORTS( 67)/'SUBROUTINE '/ X DATA CFORTS( 68)/'WRITE '/ X DATA CFORTS( 69)/'ASSIGNMENT '/ X DATA CFORTS( 70)/'ASSIGNMENT '/ X DATA CFORTS( 71)/'ASSIGNMENT '/ XC X DATA IFOK /13,31,32,42,48,52,53,54,57,58,59,61, 68,69,70,71,30,34, X +35,36,37,38,39,8,9,12,21,22,24,41,47,60,14,43,49,62,11/ X FOK = .FALSE. X IF(INDE.GT.MXSTAT.OR.INDE.LT.1) THEN X WRITE(MZUNIT,500) X RETURN X ENDIF X DO 10 I=1,LFOK X IF(INDE.EQ.IFOK(I)) RETURN X 10 CONTINUE X FOK = .TRUE. X CNAM = CFORTS(INDE) X ILEN = INDEX(CNAM,' ')-1 X RETURN X 500 FORMAT(1X,'!!! NON-FATAL ERROR IN DEFSTA') X END / echo 'x - SECPAS.f' sed 's/^X//' > SECPAS.f << '/' X SUBROUTINE SECPAS(NGLOBF,LIMPNO) X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'FLWORK.h' X include 'KEYCOM.h' X include 'TYPDEF.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X include 'USIGNO.h' X include 'USLIST.h' X include 'USGCOM.h' X include 'USSTMT.h' X include 'USUNIT.h' X include 'USARGS.h' X include 'USLTYD.h' X include 'CHECKS.h' X PARAMETER (MNUMP=100) X CHARACTER*(MXNMCH) CNAM,CNAMF,CNAMP(MNUMP) X CHARACTER*(NOARG) CSTRIN,CDIM,CDIMN(10) X CHARACTER*(MDIMST) CSTAT X INTEGER ICNAMP(MNUMP),NSEND2(700) X INTEGER IDO(100) X LOGICAL LIMPNO,BTEST X IOSM = 0 X IOSP = 0 X IOSD = 0 X IOSS = 0 X IOSO = 0 X IOSE = 0 X NSTFUN = 0 X NUMP = 0 X NUMF = 0 X NSTFIN = 0 X DO 10 II=1,MNUMP X CNAMP(II)=' ' X ICNAMP(II) = 0 X 10 CONTINUE X DO 20 I=1,100 X IDO(I) = 0 X 20 CONTINUE X MNTDO=0 X MNTIF=0 X NKALL=0 X LIMPNO = .FALSE. X DO 330 IST=1,NSTAMM X ICL1 = ICLASS(IST,1) X ICL2 = ICLASS(IST,2) X IF(ICL1.EQ.0.OR.ICL1.EQ.999) GOTO 330 X NST = NFLINE(IST) X NFI = NLLINE(IST) XC GET STATEMENT NAMES X ICURCL(1)=ICL1 X ICURCL(2)=ICL2 X ISNAME = IRNAME+NRNAME X CALL EXTRAC(IST,'FULL') X CALL GETALL XC make check for MIXED MODE EXPRESSIONS X IF(LCHECK(37)) CALL MIXMOD(NGLOBF) XC if TREE info, find current DO/IF level. After Grote. X IF(ACTION(29)) THEN X ICLE=ISTMDS(6,ICURCL(1)) X IF(ICLE.EQ.39) THEN X MNTIF=MNTIF+1 X ELSEIF(ICLE.EQ.27) THEN X MNTIF=MNTIF-1 X ELSEIF(ICLE.EQ.20) THEN X IF(MNTDO.LT.100) THEN X MNTDO=MNTDO+1 X CALL GETINT(SSTA,1,NCHST,KFCH,KLCH,NN) X IDO(MNTDO)=NN X ENDIF X ELSEIF(MNTDO.GT.0) THEN X K=NEXTIN(SIMA(NFLINE(NSTREF)),1,5) X KST=MNTDO X DO 30 I=KST,1,-1 X IF(IDO(I).NE.K) GOTO 40 X MNTDO=MNTDO-1 X 30 CONTINUE X 40 CONTINUE X ENDIF XC check for CALL X IF(ICLE.EQ.7) THEN X IF(NKALL.LT.MKALL) THEN X NKALL = NKALL + 1 X CKALLN(NKALL) = SNAMES(ISNAME+1) X KALLIF(NKALL) = MNTIF X KALLDO(NKALL) = MNTDO X ENDIF X ELSE IF(ICL1.EQ.IIF) THEN X IF(ISTMDS(6,ICURCL(2)).EQ.7) THEN X IF(NKALL.LT.MKALL) THEN X INDB=INDEX(SSTA,'(')+1 X CALL SKIPLV(SSTA,INDB,NCHST,.FALSE.,IEN,ILEV) X INDB=IEN+1 X IFOU=999 X DO 50 ISN=1,NSNAME X IF(NSSTRT(ISN).GT.INDB.AND.NSSTRT(ISN).LT.IFOU) X + THEN X IFOU=NSSTRT(ISN) X ISNF=ISN X ENDIF X 50 CONTINUE X NKALL = NKALL + 1 X CKALLN(NKALL) = SNAMES(ISNAME+ISNF) X KALLIF(NKALL) = MNTIF+1 X KALLDO(NKALL) = MNTDO X ENDIF X ENDIF X ENDIF XC check for use of FUNCTIONs X IF(ICLE.EQ.2.OR.ISTMDS(6,ICURCL(2)).EQ.2) THEN XC this is an assignment statement X DO 80 IS=1,NSNAME X DO 60 IR=1,NRNAME X IF(SNAMES(IR+IRNAME).NE.SNAMES(IS+ISNAME)) GOTO 60 X GOTO 70 X 60 CONTINUE X GOTO 80 X 70 IF(.NOT.BTEST(NAMTYP(IR+IRNAME),16)) GOTO 80 X IF(NKALL.GE.MKALL) GOTO 90 X NKALL = NKALL+1 X CKALLN(NKALL) = SNAMES(IR+IRNAME) X KALLIF(NKALL) = MNTIF X KALLDO(NKALL) = MNTDO X IF(ICLE.EQ.IIF) KALLIF(NKALL) = MNTIF+1 X 80 CONTINUE X 90 CONTINUE X ENDIF X ENDIF XC remove all blanks in statement X DO 100 IS=1,NSNAME X NSEND2(IS)=NSEND(IS) X 100 CONTINUE X NCHAS = 0 X DO 120 IC=1,NCHST X IF(SSTA(IC:IC).EQ.' ') THEN XC update NSEND into NSEND2 X DO 110 ISN=1,NSNAME X IF(NSEND2(ISN).GT.IC) NSEND2(ISN)=NSEND2(ISN)-1 X 110 CONTINUE X GOTO 120 X ENDIF X NCHAS = NCHAS + 1 X CSTAT(NCHAS:NCHAS) = SSTA(IC:IC) X 120 CONTINUE XC XC trap IMPLICIT NONE or IMPLICIT LOGICAL(A-Z) X IF(INDEX(CSTAT,'IMPLICITNONE').NE.0) LIMPNO=.TRUE. X IF(INDEX(CSTAT,'IMPLICITLOGICAL(A-Z)').NE.0) LIMPNO=.TRUE. X IF(ICL1.EQ.ILL) GOTO 330 XC XC At module start, find argument list if any X IF(LMODUL(ICL1)) THEN X NARGS = NSNAME - 1 X DO 130 IA=1,NARGS X CARGNM(IA) = SNAMES(ISNAME+1+IA) X 130 CONTINUE X ENDIF XC XC within module, check for dimensionality of items in argument list X IF(ICL1.EQ.0.OR.ICL1.EQ.999.OR.LIFF(ICL1)) GOTO 250 X DO 240 ISN=1,NSNAME XC find name in routine list for NAMTYP check X DO 140 IRN=1,NRNAME X IF(SNAMES(IRN+IRNAME).EQ.SNAMES(ISN+ISNAME)) GOTO 150 X 140 CONTINUE X GOTO 240 X 150 NTYP = NAMTYP(IRN+IRNAME) X CNAM = ' ' X CNAM = SNAMES(ISN+ISNAME) X ILEN1 = INDEX(CNAM,' ')-1 X IF(ILEN1.EQ.-1) ILEN1 = MXNMCH X IFOU = 0 X DO 160 IARG=1,NARGS X ILEN2 = INDEX(CARGNM(IARG),' ')-1 X IF(ILEN2.EQ.-1) ILEN2 = MXNMCH X IF(ILEN2.NE.ILEN1) GOTO 160 X IF(CARGNM(IARG)(:ILEN2).NE.CNAM(:ILEN1)) GOTO 160 X IFOU = IARG X GOTO 170 X 160 CONTINUE X 170 IF(IFOU.EQ.0) GOTO 240 XC found in argument list XC X IF(.NOT.BTEST(NTYP,17).AND..NOT.BTEST(NTYP,5)) THEN XC fill info in USARGS X IF(ACTION(29)) THEN X IF(CARGTY(IFOU).EQ.' ') THEN X IF(BTEST(NTYP,4)) CARGTY(IFOU)='DOUBLEPRECISION' X LG = INDEX(CARGTY(IFOU),' ') X IF(BTEST(NTYP,0)) CARGTY(IFOU)(LG:)='INTEGER' X IF(BTEST(NTYP,1)) CARGTY(IFOU)(LG:)='REAL' X IF(BTEST(NTYP,2)) CARGTY(IFOU)(LG:)='LOGICAL' X IF(BTEST(NTYP,3)) CARGTY(IFOU)(LG:)='COMPLEX' X ENDIF X ENDIF X GOTO 240 X ENDIF X IF(LDIMEN(ICL1)) THEN XC dimensioned or character variable XC first treat CHARACTER*() cases XC X IC1 = 13 X IF(INDEX(CSTAT,'CHARACTER*').NE.0) THEN X IC1 = 12 X IPOSS = INDEX(CSTAT(:NCHAS),'CHARACTER*')+10 X ILEV = 0 X CDIM = ' ' X N = 0 X DO 180 IC=IPOSS,NCHAS X IF(CSTAT(IC:IC).EQ.'(') THEN X ILEV = ILEV + 1 X IF(N.GT.0.AND.ILEV.EQ.1) GOTO 190 X IF(ILEV.EQ.1) GOTO 180 X ELSE IF(CSTAT(IC:IC).EQ.')') THEN X ILEV = ILEV - 1 X IF(ILEV.EQ.0) GOTO 190 X ENDIF X N = N+1 X CDIM(N:N) = CSTAT(IC:IC) X 180 CONTINUE X 190 CONTINUE XC fill info in USARGS X IF(N.EQ.0) THEN X N = 1 X CDIM(1:1) = '?' X ENDIF X IF(ACTION(29)) THEN X CARGTY(IFOU) = 'CHARACTER*('//CDIM(:N)//')' X NARGDI(IFOU) = 0 X ENDIF X IF(LCHECK(38).AND.CDIM(1:1).NE.'*') THEN X WRITE(MZUNIT,500) CNAM X NGLOBF = NGLOBF + 1 X GOTO 240 X ENDIF X ENDIF XC XC now CHARACTER with length later or modified length X IPOS = NSEND2(ISN)+1 X IF(LCHARC(ICL1).OR.IC1.EQ.12) THEN X N = 0 X ILEV = 0 X CDIM = ' ' X ISTAR = 0 X DO 200 IC=IPOS,NCHAS X IF(CSTAT(IC:IC).EQ.'(') THEN X ILEV = ILEV + 1 X GOTO 200 X ELSE IF(CSTAT(IC:IC).EQ.')') THEN X ILEV = ILEV - 1 X GOTO 200 X ELSE IF(CSTAT(IC:IC).EQ.'*') THEN X IF(ILEV.EQ.0) THEN X ISTAR = 1 X GOTO 200 X ENDIF X ENDIF X IF(ILEV.EQ.0.AND.CSTAT(IC:IC).EQ.',') GOTO 210 X IF(ISTAR.EQ.0) GOTO 200 X N = N + 1 X CDIM(N:N) = CSTAT(IC:IC) X 200 CONTINUE X 210 CONTINUE XC fill info in USARGS X IF(N.EQ.0) THEN X N = 1 X CDIM(:1) = '?' X ENDIF X IF(ACTION(29)) THEN X CARGTY(IFOU) = 'CHARACTER*('//CDIM(:N)//')' X NARGDI(IFOU) = 0 X ENDIF X IF(LCHECK(39)) THEN X IF((CDIM(1:1).NE.'*'.AND.IC1.EQ.13).OR. (N.GT.0.AND X + .IC1.EQ.12.AND.CDIM(1:1).NE.'*')) THEN X WRITE(MZUNIT,500) CNAM X NGLOBF = NGLOBF + 1 X GOTO 240 X ENDIF X ENDIF X GOTO 240 X ENDIF XC a dimensioned non-character variable X IPOS2 = INDEX(CSTAT(IPOS:NCHAS),'(')+IPOS X IF(IPOS2.EQ.IPOS) GOTO 240 X IF(IPOS2.NE.IPOS+1) GOTO 240 X CALL SKIPLV(CSTAT,IPOS2,NCHAS,.FALSE.,IEN,ILEV) XC dimension clause spans IPOS2 to IEN-1 X ISTA = IPOS2 X IFIN = IEN-1 X NDIM = 0 X CDIM = ' ' X N = 0 X DO 220 IC=ISTA,IFIN X IF(CSTAT(IC:IC).EQ.',') THEN X NDIM = NDIM + 1 X CDIMN(NDIM) = ' ' X CDIMN(NDIM) = CDIM(:N) X CDIM = ' ' X N = 0 X GOTO 220 X ENDIF X N = N + 1 X CDIM(N:N) = CSTAT(IC:IC) X 220 CONTINUE X IF(N.EQ.0) THEN X N = 1 X CDIM(1:1) = '?' X ENDIF X NDIM = NDIM + 1 X CDIMN(NDIM) = ' ' X CDIMN(NDIM) = CDIM(:N) X CARGTY(IFOU) = ' ' XC fill info in USARGS X IF(ACTION(29)) THEN X IF(BTEST(NTYP,4)) CARGTY(IFOU)='DOUBLEPRECISION' X LG = INDEX(CARGTY(IFOU),' ') X IF(BTEST(NTYP,0)) CARGTY(IFOU)(LG:)='INTEGER' X IF(BTEST(NTYP,1)) CARGTY(IFOU)(LG:)='REAL' X IF(BTEST(NTYP,2)) CARGTY(IFOU)(LG:)='LOGICAL' X IF(BTEST(NTYP,3)) CARGTY(IFOU)(LG:)='COMPLEX' X X NARGDI(IFOU) = NDIM X DO 230 I=1,NDIM X CDIM=CDIMN(I) X ICOLON=INDEX(CDIM,':') X IF(ICOLON.NE.0) THEN X CARGDI(I,1,IFOU)=CDIM(1:ICOLON-1) X CARGDI(I,2,IFOU)=CDIM(ICOLON+1:INDEX(CDIM,' ') X + -1) X ELSE X CARGDI(I,1,IFOU)='1' X CARGDI(I,2,IFOU)=CDIM X ENDIF X 230 CONTINUE X ENDIF X IF(NDIM.EQ.0) GOTO 240 X ICOLON = INDEX(CDIMN(NDIM),':') X IF(ICOLON.NE.0) THEN X ILEN = INDEX(CDIMN(NDIM),' ')-1 X IF(ILEN.EQ.-1) ILEN = NOARG X CDIM = CDIMN(NDIM)(ICOLON+1:ILEN) X ELSE X CDIM = CDIMN(NDIM) X ENDIF X IF(LCHECK(44).AND.CDIM(1:1).NE.'*') THEN X WRITE(MZUNIT,510) CNAM X NGLOBF = NGLOBF + 1 X GOTO 240 X ENDIF X ENDIF X 240 CONTINUE X 250 CONTINUE X IF(LMODUS(ICL1)) THEN XC Module start X IF(LCHECK(39).AND.IOSE+IOSO+IOSS+IOSD+IOSP.NE.0) THEN X WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) X ENDIF X IOSM = 1 X ELSE IF(LDECLR(ICL1)) THEN XC PARAMETER etc X IF(LCHECK(39).AND.IOSD+IOSS+IOSO+IOSE.NE.0) THEN X WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) X NGLOBF = NGLOBF + 1 X ENDIF X IOSP = 1 X ELSE IF(LDATA(ICL1)) THEN XC DATA Statement X IF(LCHECK(39).AND.IOSS+IOSO+IOSE.NE.0) THEN X WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) X NGLOBF = NGLOBF + 1 X ENDIF X IOSD = 1 X ELSE IF(ICL1.EQ.IEND) THEN XC END Statement X IOSE = 1 X ELSE IF(LASIGN(ICL1)) THEN XC Possible statement function X IFOUN = 0 X DO 270 IN=1,NRNAME X IF(.NOT.BTEST(NAMTYP(IRNAME+IN),9)) GOTO 270 X CNAM = SNAMES(IRNAME+IN) X ILEN = INDEX(CNAM,' ')-1 X IF(ILEN.EQ.-1) ILEN = MXNMCH XC Search for the statement function name at the left of XC an '=' sign . Simple approach but probably not rigorous . X IND = INDEX(SIMA(NST),CNAM(:ILEN)) XC XC CONFIRM THAT THIS IS THE FIRST NAME ON THE LINE XC X DO 259 ICHP=7,IND-1 X IF(SIMA(NST)(ICHP:ICHP).NE.' ') GOTO 270 X 259 CONTINUE X INDE = INDEX(SIMA(NST),'=') X IF(INDE.LT.IND) GOTO 270 X IF(IND.EQ.0) GOTO 270 X DO 260 ILOC=IND+ILEN,MXLINE X IF(SIMA(NST)(ILOC:ILOC).EQ.' ') GOTO 260 X IF(SIMA(NST)(ILOC:ILOC).EQ.'=') THEN X IFOUN = 1 X CNAMF = CNAM X GOTO 280 X ELSE IF(SIMA(NST)(ILOC:ILOC).EQ.'(') THEN X NP = 0 X IF(NUMP.GE.MNUMP) THEN X WRITE(MZUNIT,520) X GOTO 280 X ENDIF X NUMP = NUMP + 1 X GOTO 260 X ENDIF X IF(SIMA(NST)(ILOC:ILOC).GE.'A'.AND. SIMA(NST) X + (ILOC:ILOC) .LE.'Z') THEN X NP = NP + 1 X IF(NP.GT.MXNMCH) GOTO 260 X CNAMP(NUMP)(NP:NP) = SIMA(NST)(ILOC:ILOC) X ENDIF X IF(SIMA(NST)(ILOC:ILOC).EQ.',') THEN X NP = 0 X IF(NUMP.GE.MNUMP) THEN X WRITE(MZUNIT,520) X GOTO 280 X ENDIF X NUMP = NUMP + 1 X ENDIF X 260 CONTINUE X 270 CONTINUE X 280 CONTINUE X IF(IFOUN.EQ.1) THEN X NUMF = NUMF + 1 XC Check that statement function surrounded by comment cards X IF(NSTFUN.EQ.0) THEN X NSTFUN = NST X IF(LCHECK(40)) THEN X IF(SIMA(NST-1)(1:1).NE.'C'.AND.SIMA(NST-1)(1:1).NE. X + '*') THEN X WRITE(MZUNIT,530) CNAMF X NGLOBF = NGLOBF + 1 X ENDIF X ENDIF X ENDIF X NSTFIN = NFI+1 X IOSS = 1 X IF(LCHECK(39).AND.IOSO+IOSE.NE.0) THEN X WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) X NGLOBF = NGLOBF + 1 X ENDIF X ELSE XC OTHER Statement X IF(LCHECK(39).AND.IOSE.EQ.1) THEN X WRITE(MZUNIT,550) (SIMA(I),I=NST,NFI) X NGLOBF = NGLOBF + 1 X ENDIF X IOSO = 1 X ENDIF XC Single occurences of names forced here X DO 300 II=1,NUMP-1 X CNAM=CNAMP(II) X DO 290 IJ=II+1,NUMP X IF(CNAM.EQ.CNAMP(IJ)) ICNAMP(IJ)=ICNAMP(II) X 290 CONTINUE X 300 CONTINUE XC Check that statement function variables are not used elsewhere X IF(IFOUN.EQ.0) THEN X DO 320 ISN=1,NSNAME X CNAM = SNAMES(ISNAME+ISN) X DO 310 ISN2=1,NUMP X IF(CNAM.EQ.CNAMP(ISN2)) THEN X IF(LCHECK(41).AND.ICNAMP(ISN2).EQ.0) THEN X WRITE(MZUNIT,540) CNAM X NGLOBF = NGLOBF + 1 X ENDIF X ICNAMP(ISN2) = 1 X GOTO 320 X ENDIF X 310 CONTINUE X 320 CONTINUE X ENDIF X ENDIF X 330 CONTINUE X IF(LCHECK(40)) THEN X IF(NUMF.GT.1.AND.SIMA(NSTFIN)(1:1).NE.'C'.AND. SIMA(NSTFIN) X + (1:1) .NE.'*') THEN X WRITE(MZUNIT,530) CNAMF X NGLOBF = NGLOBF + 1 X ENDIF X ENDIF X RETURN X 500 FORMAT(1X,'!!! WARNING ... ARGUMENT ',A,' PASSED TO THIS ', X +'MODULE, IS NOT CHARACTER*(*)') X 510 FORMAT(1X,'!!! WARNING ... ARGUMENT ',A,' PASSED TO THIS ', X +'MODULE, DOES NOT HAVE LAST DIMENSION "*"') X 520 FORMAT(1X,'!!! NON-FATAL ERROR IN SECPAS . MNUMP EXCEEDED') X 530 FORMAT(1X,'!!! WARNING ... STATEMENT FUNCTION ',A,' IS NOT', X +' SURROUNDED BY COMMENTS') X 540 FORMAT(1X,'!!! WARNING ... VARIABLE ',A, X +',IN STATEMENT FUNCTION DEFINITION, IS USED ELSEWHERE') X 550 FORMAT(1X,'!!! WARNING ... FOLLOWING STATEMENT IS', X +' OUT OF ORDER ',(/,1X,A80)) X END / echo 'x - USSBEG.f' sed 's/^X//' > USSBEG.f << '/' X SUBROUTINE USSBEG X*----------------------------------------------------------------------- X* X*--- user start of filtered statement (treat names here) X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'FLWORK.h' X include 'KEYCOM.h' X include 'TYPDEF.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X include 'USCOMN.h' X include 'USSTMT.h' X include 'USIGNO.h' X include 'USLIST.h' X include 'USUNIT.h' X include 'USARGS.h' X include 'USINFN.h' X include 'USLTYD.h' X include 'CHECKS.h' X CHARACTER*(MXNMCH) CNAM X CHARACTER*25 C25NAM X LOGICAL FOK X DATA ICALL /0/ X IF(UNFLP) RETURN X IF(ICALL.EQ.0) THEN X ISGLOB = 0 X ICALL = 1 X ENDIF XC Determine whether this module is to be processed X IF(.NOT.RPROCS) RETURN X NST = NFLINE(NSTREF) X NFI = NLLINE(NSTREF) X ICL1 = ICURCL(1) X ICL2 = ICURCL(2) XC ICL1 is class of first part of statement XC ICL2 is class of second part if ICL1 is an IF statement X IF(LMODUS(ICL1)) THEN XC Module start XC X IF(NIGNOS.NE.0) THEN X CNAM = SNAMES(ISNAME+1) X ILEN = INDEX(CNAM,' ')-1 X IF(ILEN.EQ.-1) ILEN = MXNMCH X DO 10 IGN=1,NIGNOS X IF(LIGNOS(IGN).NE.ILEN) GOTO 10 X IF(CIGNOS(IGN).EQ.CNAM) THEN X NFAULT = 0 X RPROCS = .FALSE. X RETURN X ENDIF X 10 CONTINUE X ENDIF X WRITE(MZUNIT,550) (SIMA(II)(7:),II=NST,NFI) X ISTMT = 0 X NCOMN = 0 X NCOMT = 0 X IFUNC = 0 XC Set FUNCTION flag X IF(LFUNCT(ICL1)) IFUNC = 1 X ICLOLD = ICL1 X NFIOLD = NFI X IF(LCHECK(11).AND.NSTREF.NE.1) WRITE(MZUNIT,560) XC Make check for module names the same as intrinsic functions X CNAM = SNAMES(ISNAME+1) X ILEN = INDEX(CNAM,' ')-1 X IF(LCHECK(12)) THEN X DO 20 I=1,LIF X IF(ILEN.NE.INDEX(CINFUN(I),' ')-1) GOTO 20 X IF(CNAM(:ILEN).NE.CINFUN(I)(:ILEN)) GOTO 20 X WRITE(MZUNIT,570) CNAM,CNAM X NFAULT = NFAULT + 1 X GOTO 30 X 20 CONTINUE X 30 CONTINUE X ENDIF XC First statement in input should be module declaration X ELSE IF(LCHECK(13).AND.ISGLOB.EQ.0.AND.NFIOLD.EQ.0) THEN X WRITE(MZUNIT,500) X NFAULT = NFAULT + 1 X ENDIF XC Make check for comment lines after start of routine X ISTMT=ISTMT+1 X IF(LCHECK(14).AND.ISTMT.EQ.2) THEN X IF(NST-NFIOLD.LT.3) THEN X WRITE(MZUNIT,580) X NFAULT = NFAULT + 1 X ENDIF X ENDIF X IF(NST-NFIOLD.GT.1) THEN X IF(USFULL) WRITE(MZUNIT,510) (II+ISGLOB,SIMA(II), II=NFIOLD+1, X + NST-1) XC Check comment lines X ICMSET = 0 X DO 40 I=NFIOLD+1,NST-1 X IF(NLTYPE(I).EQ.0) THEN XC Store comment line if TREE option requested X IF(ACTION(29).AND.SIMA(I)(1:2).EQ.'C!') THEN X IF(ICMSET.EQ.0) CMMNT = SIMA(I)(3:LARC+2) X ICMSET = 1 X ENDIF XC comment lines should start with C X IF(LCHECK(15).AND.SIMA(I)(1:1).NE.'C') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,510) I+ISGLOB,SIMA(I) X WRITE(MZUNIT,590) X NFAULT = NFAULT + 1 X ENDIF X ENDIF X 40 CONTINUE X ENDIF X NFIOLD = NFI XC Write all statements to MZUNIT if USFULL set X IF(USFULL) THEN X WRITE(MZUNIT,510) (II+ISGLOB,SIMA(II),II=NST,NFI) X ENDIF XC XC Check for comment lines in between continuations X IF(LCHECK(16).AND.NFI-NST.GT.0) THEN X DO 50 IST=NST+1,NFI-1 X IF(SIMA(IST)(:5).NE.' ') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST,NFI) X WRITE(MZUNIT,610) X NFAULT = NFAULT + 1 X GOTO 60 X ENDIF X 50 CONTINUE X 60 CONTINUE X ENDIF XC Check for standard variable types X IF(LCHECK(17).AND.LNSVT(ICL1)) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST, X + NFI) X WRITE(MZUNIT,520) X NFAULT = NFAULT + 1 X ENDIF XC Collect list of COMMON names used in this routine X IF(LCOMMN(ICL1)) THEN XC First check that only one COMMON name per COMMON statement X IPOS1 = INDEX(SSTA(:NCHST),'/') X IF(IPOS1.EQ.0) GOTO 70 X IPOS2 = INDEX(SSTA(IPOS1+1:NCHST),'/') X IF(IPOS2.EQ.0) GOTO 70 X IPOS3 = INDEX(SSTA(IPOS1+IPOS2+1:NCHST),'/') X IF(IPOS3.NE.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) X & (II+ISGLOB,SIMA(II),II =NST,NFI) X WRITE(MZUNIT,620) X NFAULT = NFAULT + 1 X ENDIF X 70 CONTINUE X NCOMT = NCOMT + 1 X IF(NCOMT.GT.MCOMT) THEN X NCOMT = NCOMT-1 X WRITE(MZUNIT,630) X GOTO 110 X ENDIF XC Take account of blank COMMON X IF(INDEX(SSTA(:NCHST),'//').NE.0.OR. X & INDEX(SSTA(:NCHST),'/ /').NE.0) THEN X SCTITL(NCOMT) = 'BLANKCOM' X IST = 1 X ELSE X SCTITL(NCOMT) = SNAMES(ISNAME+1) X IST = 2 X ENDIF X ICTITL(NCOMT) = NCOMN + 1 X DO 100 ISN=IST,NSNAME XC We ensure that the list of names for this COMMON block does not XC include parameters. This is done by checking for no hanging parentheses. X IBEG = NSSTRT(ISN) X ICOUNB = 0 X DO 95 ICH=1,IBEG-1 X IF(SSTA(ICH:ICH).EQ.'(') THEN X ICOUNB=ICOUNB+1 X ELSE IF(SSTA(ICH:ICH).EQ.')') THEN X ICOUNB=ICOUNB-1 X ENDIF X 95 CONTINUE X IF(ICOUNB.NE.0) GOTO 100 X NCOMN = NCOMN + 1 X IF(NCOMN.GT.MCOMN) THEN X NCOMN = NCOMN-1 X WRITE(MZUNIT,640) X GOTO 110 X ENDIF X SCNAME(NCOMN) = SNAMES(ISNAME+ISN) X ICNAME(NCOMN) = NCOMT X 100 CONTINUE X 110 CONTINUE X ENDIF XC Check for statements which dimension outside COMMON X IF(LCHECK(19).AND.LDIMEN(ICL1)) THEN X IOVER = 0 X DO 150 I=1,NSNAME X CNAM = SNAMES(I+ISNAME) X ILEN = INDEX(CNAM,' ')-1 X IF(ILEN.EQ.-1) GOTO 150 X MATCH = 0 X DO 130 IC=1,NCOMN X ILEN1 = INDEX(SCNAME(IC),' ')-1 X IF(ILEN1.NE.ILEN) GOTO 130 X IF(CNAM.NE.SCNAME(IC)) GOTO 130 X MATCH = 1 XC Now have found a declaration of a name in COMMON XC Search for position of name in the statement X INDE = NSEND(I)+1 XC Search for ( or , and ignore blanks X DO 120 IPL = INDE,NCHST X IF(SSTA(IPL:IPL).EQ.' ') GOTO 120 X IF(SSTA(IPL:IPL).EQ.',') GOTO 140 X IF(SSTA(IPL:IPL).EQ.'(') THEN XC array declaration X IF(IOVER.EQ.0.AND..NOT.USFULL) WRITE(MZUNIT,850) X + (II+ ISGLOB, SIMA(II),II=NST,NFI) X WRITE(MZUNIT,650) CNAM X NFAULT = NFAULT + 1 X IOVER = 1 X GOTO 150 X ELSE X GOTO 140 X ENDIF X 120 CONTINUE X 130 CONTINUE X 140 CONTINUE X 150 CONTINUE X ENDIF XC Check for embedded blanks in names X IF(LCHECK(20)) THEN X IDONE = 0 X DO 160 I=1,NSNAME X CNAM=SNAMES(I+ISNAME) X ILEN1 = INDEX(CNAM,' ')-1 X IF(ILEN1.EQ.-1) ILEN1 = MXNMCH X IF(ILEN1.GT.6) GOTO 160 X NS = NSSTRT(I) X NE = NSEND(I) X ILEN2 = NE-NS+1 X IF(ILEN2.NE.ILEN1) THEN X IF(IDONE.EQ.0.AND..NOT.USFULL) WRITE(MZUNIT,850) (II X + +ISGLOB, SIMA(II),II=NST, NFI) X WRITE(MZUNIT,660) CNAM X IDONE = 1 X NFAULT = NFAULT + 1 X ENDIF X 160 CONTINUE X ENDIF XC Now check for embedded blanks in syntactic entities X NF1 = ISTMDS(3,ICL1) X NL1 = ISTMDS(4,ICL1) X IF(LIFF(ICL1)) THEN X NF2 = ISTMDS(3,ICL2) X NL2 = ISTMDS(4,ICL2) X ELSE X NF2 = 0 X ENDIF X IF(LCHECK(21)) THEN XC DEFSTA returns FOK=.TRUE. if statement ICL1 is to be checked X CALL DEFSTA(ICL1,ILEN,C25NAM,FOK) X IF(FOK) THEN X INDE = INDEX(SIMA(NST),C25NAM(:ILEN)) X IF(INDE.EQ.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,670) C25NAM X NFAULT = NFAULT + 1 X ELSE X IF(SIMA(NST)(INDE+ILEN:INDE+ILEN).NE.' ') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II), X + II =NST,NFI) X WRITE(MZUNIT,680) C25NAM X NFAULT = NFAULT + 1 X ENDIF X ENDIF X ENDIF XC Special treatment of GO TO and ELSE IF X IF(LELSE(ICL1)) THEN X INDE = INDEX(SSTA(:NCHST),'ELSE') X IF(INDE.EQ.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II), II X + =NST,NFI) X WRITE(MZUNIT,690) X NFAULT = NFAULT + 1 X ELSE X IBL = 0 X DO 170 ICH=INDE+4,NCHST X IF(SSTA(ICH:ICH).EQ.' ') THEN X IBL=IBL+1 X GOTO 170 X ELSE IF(SSTA(ICH:ICH+1).EQ.'IF') THEN X IF(IBL.GT.1) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB, X + SIMA(II), II=NST,NFI) X WRITE(MZUNIT,690) X GOTO 180 XC ELSE IF(SSTA(ICH+2:ICH+2).NE.' ') THEN XC IF(.NOT.USFULL) WRITE(MZUNIT,685) (II+ISGLOB,SIMA(II), XC & II=NST,NFI) XC WRITE(MZUNIT,610) XC GOTO 334 X ENDIF X ENDIF X GOTO 180 X 170 CONTINUE X 180 CONTINUE X ENDIF X ENDIF X IF(LGOTO(ICL1)) THEN X INDE = 0 X INDE1 = INDEX(SSTA(:NCHST),'GO TO') X IF(INDE1.EQ.0) INDE = INDEX(SSTA(:NCHST),'GOTO') X IF(INDE.EQ.0.AND.INDE1.EQ.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,710) X NFAULT = NFAULT + 1 X ELSE IF(INDE1.NE.0.AND.INDEX(SSTA(:NCHST),'GO TO ').EQ.0) X + THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,720) X NFAULT = NFAULT + 1 X ELSE IF(INDE.NE.0.AND.INDEX(SSTA(:NCHST),'GOTO ').EQ.0) X + THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,730) X NFAULT = NFAULT + 1 X ENDIF X ENDIF XC End special treatment for ICL1 X IF(NF2.NE.0) THEN X CALL DEFSTA(ICL2,ILEN,C25NAM,FOK) X IF(FOK) THEN X DO 190 IJ=NST,NFI X INDE = INDEX(SIMA(IJ),C25NAM(:ILEN)) X IF(INDE.NE.0) THEN X IF(SIMA(IJ)(INDE+ILEN:INDE+ILEN).NE.' ') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB, X + SIMA(II),II =NST,NFI) X WRITE(MZUNIT,680) C25NAM X NFAULT = NFAULT + 1 X ENDIF X GOTO 200 X ENDIF X 190 CONTINUE X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,670) C25NAM X NFAULT = NFAULT + 1 X 200 CONTINUE X ENDIF X ENDIF XC Special treatment of GO TO after IF statement X IF(LGOTO(ICL2).AND.NF2.NE.0) THEN X DO 210 IJ=NST,NFI X INDE = 0 X INDE1 = INDEX(SIMA(IJ),'GO TO') X IF(INDE1.EQ.0) INDE = INDEX(SIMA(IJ),'GOTO') X IF(INDE.NE.0) THEN X IF(INDEX(SIMA(IJ),'GOTO ').EQ.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA X + (II),II =NST,NFI) X WRITE(MZUNIT,740) X NFAULT = NFAULT + 1 X ENDIF X GOTO 220 X ELSE IF(INDE1.NE.0) THEN X IF(INDEX(SIMA(IJ),'GO TO ').EQ.0) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA X + (II),II =NST,NFI) X WRITE(MZUNIT,750) X NFAULT = NFAULT + 1 X ENDIF X GOTO 220 X ELSE IF(IJ.EQ.NFI) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II), X + II =NST,NFI) X WRITE(MZUNIT,760) X NFAULT = NFAULT + 1 X GOTO 220 X ENDIF X 210 CONTINUE X 220 CONTINUE X ENDIF X ENDIF XC End special treatment for ICL2 GOTO X IF(LCHECK(22).AND.(LPRINT(ICL1).OR.LPRINT(ICL2))) THEN XC PRINT statement X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST, X + NFI) X WRITE(MZUNIT,770) X NFAULT = NFAULT + 1 X ELSE IF(LCHECK(23).AND.ICL1.EQ.IEND) THEN XC END statement X IF(SIMA(NST)(:5).NE.' ') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,790) X NFAULT = NFAULT + 1 X ENDIF X ELSE IF(LWRITE(ICL1).OR.LWRITE(ICL2)) THEN XC WRITE statement X IF(LCHECK(24)) THEN X ILOC = INDEX(SSTA(:NCHST),'WRITE')+5 X ILOC1 = INDEX(SSTA(ILOC:NCHST),'(') X IF(ILOC1.EQ.0.OR.ILOC.EQ.0) GOTO 240 X ILOC = ILOC1 + ILOC X DO 230 IL=ILOC,MXLINE X IF(SSTA(IL:IL).EQ.' ') GOTO 230 X IF(SSTA(IL:IL).EQ.'*') THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II), X + II =NST,NFI) X WRITE(MZUNIT,800) X NFAULT = NFAULT + 1 X ELSE X GOTO 240 X ENDIF X 230 CONTINUE X 240 CONTINUE X ENDIF X ENDIF X IF(LCHECK(26).AND.(LPAUSE(ICL1).OR.LPAUSE(ICL2))) THEN XC PAUSE statement X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST, X + NFI) X WRITE(MZUNIT,810) X NFAULT = NFAULT + 1 X ENDIF XC check for statement labels beginning in column 1 X IF(LCHECK(27)) THEN X IF(LLE(SIMA(NST)(1:1),'9').AND.LGE(SIMA(NST)(1:1),'0')) THEN X IF(.NOT.USFULL)WRITE(MZUNIT,850)(II+ISGLOB,SIMA(II),II=NST, X + NFI) X WRITE(MZUNIT,530) X NFAULT = NFAULT + 1 X ENDIF X ENDIF X IF(LCHECK(28).AND.(LSTOP(ICL1).OR.LSTOP(ICL2))) THEN XC STOP statement X IF(.NOT.LWRITE(ICLOLD)) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,820) X NFAULT = NFAULT + 1 X ENDIF X ENDIF XC Check for ENTRY in FUNCTION X IF(LCHECK(29).AND.LENTRY(ICL1).AND.IFUNC.EQ.1) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II=NST, X + NFI) X WRITE(MZUNIT,830) X NFAULT = NFAULT + 1 X ENDIF XC Check for I/O in FUNCTION X IF(LCHECK(30).AND.IFUNC.EQ.1) THEN X IF(LIO(ICL1)) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST,NFI) X WRITE(MZUNIT,780) X NFAULT = NFAULT + 1 X ENDIF X IF(LIO(ICL2)) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA(II),II X + =NST,NFI) X WRITE(MZUNIT,780) X NFAULT = NFAULT + 1 X ENDIF X ENDIF XC check for alternate RETURN X IF(LCHECK(31).AND.(LRETRN(ICL1).OR.LRETRN(ICL2))) THEN X IPOSR=INDEX(SSTA(:NCHST),'RETURN') X IF(IPOSR.NE.0.AND.IPOSR+5.NE.NCHST) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB, SIMA(II),II X + =NST, NFI) X WRITE(MZUNIT,540) X NFAULT = NFAULT + 1 X ENDIF X ENDIF XC Check for COMMON block title clash with variable name X IF(.NOT.LCOMMN(ICL1).AND..NOT.LSAVE(ICL1)) THEN X DO 280 IS=1,NSNAME X ILEN = INDEX(SNAMES(IS+ISNAME),' ')-1 X DO 250 ICT=1,NCOMT X ILEN2 = INDEX(SCTITL(ICT),' ')-1 X IF(ILEN2.NE.ILEN) GOTO 250 X IF(LCHECK(32)) THEN X IF(SNAMES(IS+ISNAME).EQ.SCTITL(ICT)) THEN X IF(.NOT.USFULL) WRITE(MZUNIT,850) (II+ISGLOB,SIMA X + (II),II =NST,NFI) X WRITE(MZUNIT,840) SCTITL(ICT),SCTITL(ICT) X NFAULT = NFAULT + 1 X GOTO 260 X ENDIF X ENDIF X 250 CONTINUE X 260 CONTINUE XC Mark COMMON block variables as used X DO 270 ICN=1,NCOMN X ILEN2 = INDEX(SCNAME(ICN),' ')-1 X IF(ILEN2.NE.ILEN) GOTO 270 X IF(SCNAME(ICN).EQ.SNAMES(IS+ISNAME)) THEN X ICM = ICNAME(ICN) X ICTITL(ICM) = -IABS(ICTITL(ICM)) X ENDIF X 270 CONTINUE X 280 CONTINUE X ENDIF XC Make ICLOLD last executable statement X IF(ISTMDS(11,ICL1).EQ.1) THEN X ICLOLD = ICL2 X IF(ICL1.NE.IIF) ICLOLD = ICL1 X ENDIF XC X 500 FORMAT(/,1X,'!!! WARNING ... INPUT FORTRAN SHOULD BEGIN', X +' WITH MODULE DECLARATION EG "PROGRAM ... "') X 510 FORMAT((1X,I6,'. ',A80)) X 520 FORMAT(1X,'!!! WARNING ... USE STANDARD FORTRAN TYPES') X 530 FORMAT(1X,'!!! STATEMENT HAS LABEL BEGINNING IN COLUMN 1') X 540 FORMAT(1X,'!!! STATEMENT USES THE ALTERNATE RETURN FACILITY') X 550 FORMAT(/,1X,20('+'), ' BEGIN MODULE CHECKS ',10('+'), /, X +21X,' FOR ',A80,(/,1X,A80)) X 560 FORMAT(1X,'!!! WARNING ... AVOID COMMENT LINES', X +' BEFORE MODULE DECLARATION') X 570 FORMAT(1X,'!!! WARNING ... MODULE ',A, X +' CLASHES WITH INTRINSIC FUNCTION ',A) X 580 FORMAT(1X,'!!! WARNING ... NOT ENOUGH (<3) COMMENT', X +' LINES AT START OF MODULE') X 590 FORMAT(1X,'!!! COMMENT DOES NOT START WITH "C"') X 600 FORMAT(1X,' IT SHOULD BE A HISTORIAN "CALL" ANYWAY') X 610 FORMAT(1X,'!!! STATEMENT HAS COMMENT PLACED BEFORE CONTINUATION') X 620 FORMAT(1X,'!!! STATEMENT CONTAINS >1 COMMON DEFINITION') X 630 FORMAT(1X,'!!! NON-FATAL ERROR IN USSBEG . MCOMT EXCEEDED') X 640 FORMAT(1X,'!!! NON-FATAL ERROR IN USSBEG . MCOMN EXCEEDED') X 650 FORMAT(1X,'!!! STATEMENT DIMENSIONS ',A,' OUTSIDE COMMON') X 660 FORMAT(1X,'!!! NAME ',A,' HAS EMBEDDED BLANKS AT SOURCE') X 670 FORMAT(1X,'!!! THE KEYWORD ',A,' CONTAINS BLANKS') X 680 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER KEYWORD ',A25) X 690 FORMAT(1X,'!!! KEYWORD "ELSE IF" CONTAINS MISPLACED BLANKS') X 700 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "ELSEIF"') X 710 FORMAT(1X,'!!! KEYWORD "GO TO" CONTAINS MISPLACED BLANKS') X 720 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GO TO"') X 730 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GOTO"') X 740 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GOTO"') X 750 FORMAT(1X,'!!! STATEMENT HAS NO BLANK AFTER "GO TO"') X 760 FORMAT(1X,'!!! STATEMENT CONTAINS EMBEDDED BLANKS IN "GO TO"') X 770 FORMAT(1X,'!!! STATEMENT SHOULD BE A WRITE STATEMENT') X 780 FORMAT(1X,'!!! I/O IN FUNCTIONS DISALLOWED') X 790 FORMAT(1X,'!!! STATEMENT SHOULD NOT HAVE LABEL') X 800 FORMAT(1X,'!!! STATEMENT SHOULD NOT HAVE LUN=*') X 810 FORMAT(1X,'!!! PAUSE STATEMENTS ARE FROWNED UPON') X 820 FORMAT(1X,'!!! STATEMENT SHOULD BE PRECEDED BY A "WRITE"') X 830 FORMAT(1X,'!!! ENTRY STATEMENTS DISALLOWED IN FUNCTION') X 840 FORMAT(1X,'!!! ',A,' CLASHES WITH COMMON BLOCK NAME ',A) X 850 FORMAT(/,(1X,I6,'. ',A80)) X END / echo 'Part 02 of Floppy complete.' exit